home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 January - Disc 2 / Macworld (1999-01) (Disk 2).dmg / Serious Demos / Symbolic Composer 4.2 / Environment / Projects / Contributed Scores / Peter Stone Punctus / Symmetries < prev    next >
Lisp/Scheme  |  1998-10-26  |  8KB  |  180 lines
  1. (def-orchestra 'orchestra
  2.    piano (lefthand1 righthand1 lefthand2 righthand2)
  3. )
  4.  
  5. ;;; part b
  6.  
  7. (defun filter-harmonize2 (mel1 mel2 mod-val tonality n-control s-values)
  8.   (diagnostic2 "filter-harmonize" $cr$)
  9.   (setq mel1 (symbol-trim (length mel2) mel1))
  10.   (prog (out1 out2 gap swap counter n n-times n-count n-values s-master semitones
  11.               maptable)
  12.     (setq maptable (build-maptable (car tonality)))
  13.     (setq counter 0)
  14.     (setq swap t)
  15.     (setq s-master s-values)
  16.     (setq semitones (car s-master))
  17.     (setq n-values n-control)
  18.     (setq n (caar n-values))
  19.     (setq n-times (cadar n-values))
  20.     (setq n-count 0)
  21.     loop
  22.     (cond ((null mel2) (return (list (nreverse out2) (nreverse out1)))))
  23.     (cond ((= counter n)
  24.            (setq counter 0)
  25.            (setq n-count (1+ n-count))
  26.            (setq swap (not swap))))
  27.     (setq counter (1+ counter))
  28.     (cond ((= n-count n-times)
  29.            (setq s-master (cdr s-master))
  30.            (when (null s-master)
  31.              (setq s-master s-values))
  32.            (setq semitones (car s-master))
  33.            (setq n-count 0)
  34.            (setq n-values (cdr n-values))
  35.            (when (null n-values)
  36.              (setq n-values n-control))
  37.            (setq n (caar n-values))
  38.            (setq n-times (cadar n-values))))
  39.     (if swap
  40.       (cond ((or (equal (car mel1) '=) (equal (car mel2) '=))
  41.              (push (car mel1) out2)
  42.              (push (car mel2) out1))
  43.             (t (setq gap (abs (- (symbol-to-mapped-integer (car mel1) maptable)
  44.                                  (symbol-to-mapped-integer (car mel2) maptable))))
  45.                (cond ((member (mod gap mod-val) semitones)
  46.                       (push (closest-harmony (symbol-to-mapped-integer (car mel2) maptable)
  47.                                              (symbol-to-mapped-integer (car mel1) maptable)
  48.                                              (car mel1) (car mel2))
  49.                             out1)
  50.                       (push (car mel1) out2))
  51.                      (t (push (car mel2) out1)
  52.                         (push (car mel1) out2)))))
  53.       (cond ((or (equal (car mel1) '=) (equal (car mel2) '=))
  54.              (push (car mel2) out1)
  55.              (push (car mel1) out2))
  56.             (t (setq gap (abs (- (symbol-to-mapped-integer (car mel1) maptable)
  57.                                  (symbol-to-mapped-integer (car mel2) maptable))))
  58.                (cond ((member (mod gap mod-val) semitones)
  59.                       (push (closest-harmony (symbol-to-mapped-integer (car mel1) maptable)
  60.                                              (symbol-to-mapped-integer (car mel2) maptable)
  61.                                              (car mel2) (car mel1))
  62.                             out2)
  63.                       (push (car mel2) out1))
  64.                      (t (push (car mel1) out2)
  65.                         (push (car mel2) out1))))))
  66.     (pop mel1) 
  67.     (pop mel2)
  68.     (go loop)))
  69.  
  70. (defun closest-harmony (m1 m2 s1 s2)
  71.   (if (> (get-random 0 10) 5)
  72.         '=
  73.         (integer-to-symbol (+ (symbol-to-integer s2) 3))))
  74.  
  75. (defun symbol-mod (n offset s)
  76.   (if (equal s '=)
  77.     '=
  78.     (if (< (symbol-to-integer s) n)
  79.       s
  80.       (integer-to-symbol (+ offset (mod (symbol-to-integer s) n))))))
  81.  
  82. (defun symbol-fold (n offset s)
  83.   (mapcar #'(lambda (x) (symbol-mod n offset x)) s))
  84.  
  85. (init-rnd 0.79823621123)
  86.  
  87. (setq freq (fibonacci (setq fib (get-random 3 20)))) 
  88.  
  89. (setq samples (* 512 (/ 256 32)))
  90.  
  91. (setq modulator (vector-mix (gen-ramp (fibonacci (setq r1 (get-random 3 20))) 0.4 samples)
  92.                             (gen-triangle (fibonacci (setq r2 (get-random 3 20))) 0.35 samples)))
  93.  
  94. (setq theme (vector-to-symbol a z
  95.                               (vector-modulate (gen-sin freq 0.5 samples)
  96.                                                modulator)))
  97.  
  98. (setq melody-1-source theme)
  99.  
  100. (setq melody-2-source  
  101.       (vector-to-symbol a z
  102.                         (vector-modulate (gen-sin freq 0.5 samples 90)
  103.                                          modulator)))
  104.  
  105. (setq harmonized-melodies
  106.    (filter-harmonize2 melody-1-source melody-2-source 24 
  107.                    (activate-tonality (major g 3))
  108.                    '((16 2) (2 16))
  109.                    '((1 2 6 10 11))))
  110.  
  111. (setq melody-1-mat (symbol-fold 14 7 (filter-deactivate 4 40 (find-change (car harmonized-melodies)))))
  112. (setq melody-2-mat (symbol-fold 14 7 (filter-deactivate 3 50 (find-change (cadr harmonized-melodies)))))
  113.  
  114. (setq melody-1 melody-1-mat)
  115.  
  116. (setq melody-2
  117.       (symbol-remove
  118.        (find-common melody-1-mat melody-2-mat)
  119.        melody-2-mat))
  120.  
  121. (setq tempo-zone-len (/ (get-ratio '256/1 :ratio)
  122.                         (get-ratio '1/8 :ratio)))
  123.  
  124. (def-section prelude4
  125.   default
  126.     zone '(256/1)
  127.     tempo-zones (symbol-trim tempo-zone-len '(1/8))
  128.     tempo       (vector-to-list (vector-round 58 85 (gen-fourier 
  129.                       '(0.9 2 5 7) ; frequencies
  130.                       '(0.9 0.4 (gen-sin 40 0.22 64) 0.2) ; amplitudes
  131.                       '(0 45 90) ; initial phases
  132.                       tempo-zone-len)))
  133.   lefthand1
  134.     channel 4 
  135.     tonality (activate-tonality (hirajoshi g 3 4024))
  136.     symbol melody-1
  137.     length (vector-to-list (length-quantize 1/16 -1/8 1/2 (vector-modulate (gen-sin freq 0.5 samples)
  138.                                                                            modulator)))
  139.     duration (vector-to-list (vector-round (get-tick '3/1) (get-tick '1/20) (vector-modulate (gen-sin freq 0.5 samples 90)
  140.                                                                            modulator)))
  141.     velocity (symbol-to-velocity 35 110 3 (symbol-scroll 256 theme))
  142.     tuning (vector-to-list (vector-round -300 300 (gen-noise-white samples 1 0.1212)))
  143.   righthand1
  144.     channel 1 
  145.     tonality (activate-tonality (hirajoshi g 2 4024))
  146.     symbol melody-2
  147.     length (vector-to-list (length-quantize 1/16 -1/8 1/2 (vector-modulate (gen-sin freq 0.5 samples 90)
  148.                                                                            modulator)))
  149.     duration (vector-to-list (vector-round (get-tick '3/1) (get-tick '1/20) (vector-modulate (gen-sin freq 0.5 samples)
  150.                                                                            modulator)))
  151.     velocity (symbol-to-velocity 35 70 2 (reverse theme))
  152.     tuning (vector-to-list (vector-round -300 300 (gen-noise-white samples 1 0.212)))
  153.   lefthand2
  154.     channel 2 
  155.     tonality (activate-tonality (hirajoshi g 3 4024))
  156.     symbol melody-1
  157.     length (vector-to-list (length-quantize 1/16 -1/8 1/2 (vector-modulate (gen-sin freq 0.5 samples)
  158.                                                                            modulator)))
  159.     duration (vector-to-list (vector-round (get-tick '3/1) (get-tick '1/20) (vector-modulate (gen-sin freq 0.5 samples 90)
  160.                                                                            modulator)))
  161.     velocity (symbol-to-velocity 35 110 3 (symbol-scroll 256 theme))
  162.     ;tuning (vector-to-list (vector-round -300 300 (gen-noise-white samples 1 0.51212)))
  163.   righthand2
  164.     channel 5 
  165.     tonality (activate-tonality (hirajoshi g 2 4024))
  166.     symbol melody-2
  167.     length (vector-to-list (length-quantize 1/16 -1/8 1/2 (vector-modulate (gen-sin freq 0.5 samples 90)
  168.                                                                            modulator)))
  169.     duration (vector-to-list (vector-round (get-tick '3/1) (get-tick '1/20) (vector-modulate (gen-sin freq 0.5 samples)
  170.                                                                            modulator)))
  171.     velocity (symbol-to-velocity 35 70 2 (reverse theme))
  172.     ;tuning (vector-to-list (vector-round -300 300 (gen-noise-white samples 1 0.52212)))
  173. )
  174.  
  175. (midiport :printer)
  176.  
  177. (play-file-p nil   ; nil places song midi in the same directory as the score
  178.   piano '(prelude4)
  179. )
  180.